MacTech 1 to 12/MacTech-vol-1-12.toast/Source/MacTech® Magazine/Volume 05 - 1989/05.01 Jan 89/LightTrace/LightTrace.p

Text File | 1988-09-15 | 9.9 KB | 484 lines | [TEXT/PJMM]

unit LightTrace;

interface

    procedure InitTracing;{ call this to init Trace vars to safe values }

    procedure StartTracing (toText, toScreen, toFile: boolean);{ Start tracing all Subroutines }

    procedure EndTracing;{ return to normal operation }

    procedure WriteComment (Str: str255);{ write Str to Trace output }

{ The 'Of' functions are useful when formatting output that must be a Str255. }
{ Also, try them in your observe window. eg. Rectof(ThePort^.ClipRgn^^.RgnBBox) }

    function IntOf (Int: longint): str255;{ convert the Int to a Decimal Str255 }

    function HexOf (lll: longint): str255;{ convert the Int to a Hex Str255 }

    function PointOf (fff: Point): str255;{ convert the Point to a Str255 }

    function RectOf (R: Rect): str255;{ convert the Rect to a Str255 }

    procedure TraceProcTop;{ don't call this yourself}

    procedure TraceProcBot;{ don't call this yourself}

implementation

    type
        intsArr = array[0..16000] of integer;
        intsArrP = ^intsArr;

    var
        indent: integer;
        OldTrap7, OldTrap8: longint;
        doText, doScreen, doFile, started: boolean;
        ScreenWindow: grafPtr;
        TracePB: paramBlockRec;


    procedure ScanForRts (var iP: intsArrP);
    forward;

    procedure ReplaceTrap7;
    external;
    procedure ReplaceTrap8;
    external;


    function GetRTS: longint;
    inline
        $2EAE, $0004;

    function IntOf; {(int : longint) : str255}
        var
            str: str255;
    begin
        NumToString(int, str);
        IntOf := str;
    end;

    function HexOf; { (lll : longint) : str255}
        var
            str, str2: str255;
            i: integer;
            c: char;
    begin
        if lll = 0 then
            str := '$0'
        else
            begin
                str := '';
                while (lll <> 0) do
                    begin
                        i := lll mod 16;
                        if i < 10 then
                            c := chr(ord('0') + i)
                        else
                            c := chr(ord('A') + (i - 10));
                        str2 := 'x';
                        str2[1] := c;
                        str := concat(str2, str);
                        lll := BitShift(lll, -4);
                    end;
                str := concat('$', str)
            end;
        HexOf := str;
    end;


    function Pointof;{  (fff :  Point) : str255}
        var
            str: str255;
    begin
        str := concat(IntOf(fff.h), ' ', IntOf(fff.v));
        Pointof := str;
    end;


    function RectOf; {(R : Rect) : str255}
        var
            str: str255;
    begin
        with R do
            str := concat(Intof(left), ' ', Intof(top), ' ', Intof(right), ' ', Intof(bottom), ' ');
        RectOf := str;
    end;


    procedure InitTracing;
    begin
        started := false;
        doText := true;
        doScreen := false;
        doFile := false;
        indent := 0;
    end;

{ Open a small window in the back to see our output }
{ set ScreenWindow to point to this window }
    procedure MakeScreenWindow;
        var
            r: rect;
            OldPort: GrafPtr;
    begin
        getPort(OldPort);
        setRect(r, 4, 40, 156, 140);
        ScreenWindow := NewWindow(nil, r, 'Trace Info', true, 0, nil, false, 0);
        setport(ScreenWindow);
        textmode(srccopy);
        textFont(1);
        textsize(9);
        textFont(4);{monaco}
        moveto(4, 16);
        setport(OldPort);
    end;

{ remove ScreenWindow from the screen and from memory }
    procedure RemoveScreenWindow;
    begin
        if doScreen then
            DisposeWindow(ScreenWindow);
    end;

{ do this to write a cr to the screen }
    procedure ScreenLn;
        var
            ThePen, poi: point;
            r: rect;
            aRgn: RgnHandle;
            OldPort: GrafPtr;
    begin
        GetPort(OldPort);
        SetPort(ScreenWindow);
        r := ScreenWindow^.PortRect;
        GetPen(ThePen);
        ThePen.h := r.left + 4;
        ThePen.v := ThePen.v + 12; { move thePen down }
        if (ThePen.v + 12) > r.bottom then
            begin { scroll up if necessary }
                aRgn := NewRgn;
                ScrollRect(r, 0, -12, aRgn);
                DisposeRgn(aRgn);
                ThePen.v := ThePen.v - 12;
                setorigin(0, 0);
                repeat { pause feature }
                    GetMouse(poi);
                until not ptInRect(poi, r);
            end;
        moveto(ThePen.h, ThePen.v);
        setPort(OldPort);
    end;

{ This does a Write to our window }
    procedure WriteScreen (str: str255);
        var
            ThePen: point;
            r: rect;
            OldPort: GrafPtr;
            cr: str255;
    begin
        cr := 'x';
        cr[1] := chr(13);
        GetPort(OldPort);
        SetPort(ScreenWindow);
        r := ScreenWindow^.PortRect;
        GetPen(ThePen);
        if (ThePen.h + stringwidth(str) > r.right) or (pos(cr, str) > 0) then
            ScreenLn;
        DrawString(str);
        SetPort(OldPort);
    end;

{ This does a WriteLn to our window }
    procedure WriteScreenLn (str: str255);
        var
            i: integer;
            ThePen: point;
            r: rect;
            OldPort: GrafPtr;
    begin
        GetPort(OldPort);
        SetPort(ScreenWindow);
        WriteScreen(str);
        ScreenLn;
        SetPort(OldPort);
    end;


    procedure MakeTraceFile;
        var
            err: integer;
            str: str255;
    begin
        str := 'Trace_File';
        with TracePB do
            begin
                ioCompletion := nil;
                ioNamePtr := @str;
                ioVRefNum := 0;
                ioVersNum := 0;
                ioPermssn := 0;
                ioMisc := nil;
                err := PBOpen(@TracePB, false);
                if err = fnfErr then
                    begin
                        err := PBCreate(@TracePB, false);
                        if err = 0 then
                            err := PBOpen(@TracePB, false);
                    end;
                if err = 0 then
                    begin
                        ioMisc := pointer(0);
                        err := PBSetEOF(@TracePB, false);
                        if err = 0 then
                            begin
                                err := PBGetFInfo(@TracePB, false);
                                if err = 0 then
                                    with TracePB.ioFlFndrInfo do
                                        begin
                            { we'll make this an MPW text file }
                                            fdType := 'TEXT';
                                            fdCreator := 'MPS ';
                                            err := PBSetFInfo(@TracePB, false);
                                        end;{ with finder info }
                            end;{ if getFinfo OK }
                    end { if open OK }
                else
                    doFile := false;
            end; { with TracePB }
    end;{ proc MakeTraceFile }


    procedure CloseTraceFile;
        var
            err: integer;
    begin
        if doFile then
            err := PBClose(@TracePB, false);
    end;

{ same as write except the str goes to the file }
    procedure WriteFile (str: str255);
        var
            err: integer;
            eof: longint;
    begin
        if length(str) > 0 then
            if doFile then
                with TracePB do
                    begin
                        err := PBGetEof(@TracePB, false);{ ever Fail??}

                        if err <> 0 then
                            repeat
                                sysbeep(1)
                            until button;

                        eof := ord(ioMisc);
                        ioMisc := pointer(eof + length(str));
                        err := PBSetEof(@TracePB, false);
                        if err = 0 then
                            begin
                                ioBuffer := pointer(ord(@str) + 1);
                                ioReqCount := length(str);
                                ioPosMode := fsFromstart;
                                ioPosOffset := eof;
                                err := PBWrite(@TracePB, false);
                            end;{ setEof OK }
                    end;{ with TracePB }
    end;{ proc WriteFile }


{ same as writeLn(str) except output is to the file}
    procedure WriteFileLn (str: str255);
    begin
        writeFile(str);
        str := 'x';
        str[1] := chr(13);
        writeFile(str);
    end;


{ These two proc's are our output bottleneck }

    procedure WriteStr (str: str255);
    begin
        if doText then
            Write(str);
        if doScreen then
            WriteScreen(str);
        if doFile then
            WriteFile(str);
    end;

    procedure WriteStrLn (str: str255);
    begin
        if dotext then
            WriteLn(str);
        if doScreen then
            WriteScreenLn(str);
        if doFile then
            WriteFileLn(str);
    end;


{ Call ScanForRTS to find the end of a procedure.  iP is pointed }
{ past the end (at the name) }
{ Copy the name into the str.  If it is a MacApp name (16 char), }
{ then add more. }
    procedure GetTheName (var iP: intsArrP;
                                    var str: str255);
    begin
        str := '12345678';
        ScanForRts(iP);
        blockMove(@iP^, pointer(ord(@str) + 1), 8);
        if ord(str[1]) >= 128 then
            str[1] := chr(ord(str[1]) - 128);
        if ord(str[2]) >= 128 then
            begin
                str[2] := chr(ord(str[2]) - 128);
                str := concat(str, '12345678');
                blockMove(pointer(ord(@iP^) + 8), pointer(ord(@str) + 9), 8);
            end;
    end;


    procedure TraceProcTop;
        var
            str: str255;
            iP: intsArrP;
            i: integer;
    begin
        iP := pointer(GetRTS);
        GetTheName(iP, str);

        for i := 1 to indent do
            writeStr(' . ');
        indent := indent + 1;

        writeStr('BEGIN ');
        writeStrLn(str);
    end;


    procedure TraceProcBot;
        var
            str: str255;
            iP: intsArrP;
            i: integer;
    begin
        iP := pointer(GetRTS);
        GetTheName(iP, str);

        indent := indent - 1;
        for i := 1 to indent do
            writeStr(' . ');

        writeStr('END   ');
        writeStrLn(str);
    end;


    procedure WriteComment;{ (str : str255)}
        var
            i: integer;
    begin
        for i := 1 to indent do
            writeStr(' . ');
        writeStr('REM ');
        writeStrLn(str);
    end;

    procedure ScanForRts; { (var iP : intsArrP)}
        var
            count, size: longint;
            str: str255;
    begin
        count := 4000;{ max size of any procedure ?? }
        size := 0;
        while size = 0 do
            begin
                if iP^[0] = $4E5E then                            { UNLK }
                    begin
                        if (iP^[1] = $2E9F) and (iP^[2] = $4E75) then    { MOVE.l (A7)+,A7  RTS}
                            size := 6
                        else if iP^[1] = $4E75 then                        { RTS }
                            size := 4
                        else if iP^[1] = $205F then                        { MOVEA.L (A7)+,A0 }
                            begin
                                if (iP^[2] = $4FEF) and (iP^[4] = $4ED0) then        { LEA x(A7),A7  JMP (A0) }
                                    size := 10
                                else if (iP^[2] = $DFFC) and (iP^[5] = $4ED0) then    { ADD.l #x,A7  JMP (A0) }
                                    size := 12
                                else if (iP^[2] = $DEFC) and (iP^[4] = $4ED0) then    { ADD.w #x,A7  JMP (A0) }
                                    size := 10
                                else if iP^[3] = $4ED0 then                            {JMP (A0) }
                                    size := 8
                            end;
                    end;
                count := count - 2;
                if count <= 0 then
                    size := 22222;
                if size <> 0 then
                    iP := pointer(ord(iP) + size)
                else
                    iP := pointer(ord(iP) + 2)
            end;{ while size=0 }
        if count <= 0 then
            begin
                str := 'unknown';
                iP := pointer(ord(@str) + 1);
            end;
    end; { proc scan for Rts }


    procedure StartTracing; { (toText, toScreen, toFile : boolean)}
        var
            lP: ^longint;
    begin
        InitTracing;{ initialize global vars }

{ save the options as globals }
        doText := toText;
        doScreen := toScreen;
        doFile := toFile;

        started := true;

        if doscreen then
            MakeScreenWindow;
        if doFile then
            MakeTraceFile;
        if doText then
            ShowText;

        lP := pointer($80 + 4 * 7);{ trap 7}
        OldTrap7 := lP^;
        lP^ := ord(@ReplaceTrap7);
        lP := pointer($80 + 4 * 8);{ trap 8}
        OldTrap8 := lP^;
        lP^ := ord(@ReplaceTrap8);

    end;{ proc StartTracing }

    procedure EndTracing;
        var
            lP: ^longint;
    begin
        if Started then
            begin
                lP := pointer($80 + 4 * 7);{ trap 7}
                lP^ := OldTrap7;
                lP := pointer($80 + 4 * 8);{ trap 8}
                lP^ := OldTrap8;
                RemoveScreenWindow;
                CloseTraceFile;
            end;
        InitTracing;
    end;{ proc EndTracing }


end.